home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / gnu / emacs.lha / emacs-19.16 / lisp / cust-print.el < prev    next >
Lisp/Scheme  |  1993-06-09  |  20KB  |  574 lines
  1. ;;; cust-print.el --- handles print-level and print-circle.
  2.  
  3. ;; Copyright (C) 1992 Free Software Foundation, Inc.
  4.  
  5. ;; Author: Daniel LaLiberte <liberte@cs.uiuc.edu>
  6. ;; Version: 1.0
  7. ;; Adapted-By: ESR
  8. ;; Keywords: extensions
  9.  
  10. ;; This file is part of GNU Emacs.
  11.  
  12. ;; GNU Emacs is free software; you can redistribute it and/or modify
  13. ;; it under the terms of the GNU General Public License as published by
  14. ;; the Free Software Foundation; either version 2, or (at your option)
  15. ;; any later version.
  16.  
  17. ;; GNU Emacs is distributed in the hope that it will be useful,
  18. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20. ;; GNU General Public License for more details.
  21.  
  22. ;; You should have received a copy of the GNU General Public License
  23. ;; along with GNU Emacs; see the file COPYING.  If not, write to
  24. ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  25.  
  26. ;;; Commentary:
  27.  
  28. ;; This package provides a general print handler for prin1 and princ
  29. ;; that supports print-level and print-circle, and by the way,
  30. ;; print-length since the standard routines are being replaced.  Also,
  31. ;; to print custom types constructed from lists and vectors, use
  32. ;; custom-print-list and custom-print-vector.  See the documentation
  33. ;; strings of these variables for more details.  
  34.  
  35. ;; If the results of your expressions contain circular references to
  36. ;; other parts of the same structure, the standard Emacs print
  37. ;; subroutines may fail to print with an untrappable error,
  38. ;; "Apparently circular structure being printed".  If you only use cdr
  39. ;; circular lists (where cdrs of lists point back; what is the right
  40. ;; term here?), you can limit the length of printing with
  41. ;; print-length.  But car circular lists and circular vectors generate
  42. ;; the above mentioned untrappable error in Emacs version 18.  Version
  43. ;; 19 will support print-level, but it is often useful to get a better
  44. ;; print representation of circular structures; the print-circle
  45. ;; option may be used to print more concise representations.
  46.  
  47. ;; There are two main ways to use this package.  First, you may
  48. ;; replace prin1, princ, and some subroutines that use them by calling
  49. ;; install-custom-print-funcs so that any use of these functions in
  50. ;; lisp code will be affected.  Second, you could call the custom
  51. ;; routines directly, thus only affecting the printing that requires
  52. ;; them.
  53.  
  54. ;; Note that subroutines which call print subroutines directly will not
  55. ;; use the custom print functions.  In particular, the evaluation
  56. ;; functions like eval-region call the print subroutines directly.
  57. ;; Therefore, evaluating (aref circ-list 0), which calls error
  58. ;; directly (because circ-list is not an array), will jump to the top
  59. ;; level instead of printing the circular list.
  60.  
  61. ;; Obviously the right way to implement this custom-print facility
  62. ;; is in C.  Please volunteer since I don't have the time or need.
  63.  
  64. ;; Implementation design: we want to use the same list and vector
  65. ;; processing algorithm for all versions of prin1 and princ, since how
  66. ;; the processing is done depends on print-length, print-level, and
  67. ;; print-circle.  For circle printing, a preprocessing step is
  68. ;; required before the final printing.  Thanks to Jamie Zawinski
  69. ;; for motivation and algorithms.
  70.  
  71. ;;=========================================================
  72. ;; export list:
  73.  
  74. ;; print-level
  75. ;; print-circle
  76.  
  77. ;; custom-print-list
  78. ;; custom-print-vector
  79. ;; add-custom-print-list
  80. ;; add-custom-print-vector
  81.  
  82. ;; install-custom-print-funcs
  83. ;; uninstall-custom-print-funcs
  84.  
  85. ;; custom-prin1
  86. ;; custom-princ
  87. ;; custom-prin1-to-string
  88. ;; custom-print
  89. ;; custom-format
  90. ;; custom-message
  91. ;; custom-error
  92.  
  93. ;;; Code:
  94.  
  95. (provide 'custom-print)
  96.  
  97. ;;(defvar print-length nil
  98. ;;  "*Controls how many elements of a list, at each level, are printed.
  99. ;;This is defined by emacs.")
  100.  
  101. (defvar print-level nil
  102.   "*Controls how many levels deep a nested data object will print.  
  103.  
  104. If nil, printing proceeds recursively and may lead to
  105. max-lisp-eval-depth being exceeded or an untrappable error may occur:
  106. `Apparently circular structure being printed.'
  107. Also see `print-length' and `print-circle'.
  108.  
  109. If non-nil, components at levels equal to or greater than `print-level'
  110. are printed simply as `#'.  The object to be printed is at level 0,
  111. and if the object is a list or vector, its top-level components are at
  112. level 1.")
  113.  
  114.  
  115. (defvar print-circle nil
  116.   "*Controls the printing of recursive structures.  
  117.  
  118. If nil, printing proceeds recursively and may lead to
  119. `max-lisp-eval-depth' being exceeded or an untrappable error may occur:
  120. \"Apparently circular structure being printed.\"  Also see
  121. `print-length' and `print-level'.
  122.  
  123. If non-nil, shared substructures anywhere in the structure are printed
  124. with `#N=' before the first occurrence (in the order of the print
  125. representation) and `#N#' in place of each subsequent occurrence,
  126. where N is a positive decimal integer.
  127.  
  128. Currently, there is no way to read this representation in Emacs.")
  129.  
  130.  
  131. (defconst custom-print-list
  132.   nil
  133.   ;; e.g.  '((floatp . float-to-string))
  134.   "An alist for custom printing of lists.  
  135. Pairs are of the form (PRED . CONVERTER).  If PREDICATE is true
  136. for an object, then CONVERTER is called with the object and should
  137. return a string to be printed with `princ'.  
  138. Also see `custom-print-vector'.")
  139.  
  140. (defconst custom-print-vector
  141.   nil
  142.   "An alist for custom printing of vectors.  
  143. Pairs are of the form (PRED . CONVERTER).  If PREDICATE is true
  144. for an object, then CONVERTER is called with the object and should
  145. return a string to be printed with `princ'.  
  146. Also see `custom-print-list'.")
  147.  
  148.  
  149. (defun add-custom-print-list (pred converter)
  150.   "Add a pair of PREDICATE and CONVERTER to `custom-print-list'.
  151. Any pair that has the same PREDICATE is first removed."
  152.   (setq custom-print-list (cons (cons pred converter) 
  153.                 (delq (assq pred custom-print-list)
  154.                       custom-print-list))))
  155. ;; e.g. (add-custom-print-list 'floatp 'float-to-string)
  156.  
  157.  
  158. (defun add-custom-print-vector (pred converter)
  159.   "Add a pair of PREDICATE and CONVERTER to `custom-print-vector'.
  160. Any pair that has the same PREDICATE is first removed."
  161.   (setq custom-print-vector (cons (cons pred converter) 
  162.                   (delq (assq pred custom-print-vector)
  163.                     custom-print-vector))))
  164.  
  165.  
  166. ;;====================================================
  167. ;; Saving and restoring internal printing routines.
  168.  
  169. (defun cust-print-set-function-cell (symbol-pair)
  170.   (defalias (car symbol-pair) 
  171.     (symbol-function (car (cdr symbol-pair)))))
  172.  
  173.  
  174. (if (not (fboundp 'cust-print-internal-prin1))
  175.     (mapcar 'cust-print-set-function-cell
  176.         '((cust-print-internal-prin1 prin1)
  177.           (cust-print-internal-princ princ)
  178.           (cust-print-internal-print print)
  179.           (cust-print-internal-prin1-to-string prin1-to-string)
  180.           (cust-print-internal-format format)
  181.           (cust-print-internal-message message)
  182.           (cust-print-internal-error error))))
  183.  
  184.  
  185. (defun install-custom-print-funcs ()
  186.   "Replace print functions with general, customizable, Lisp versions.
  187. The internal subroutines are saved away, and you can reinstall them
  188. by running `uninstall-custom-print-funcs'."
  189.   (interactive)
  190.   (mapcar 'cust-print-set-function-cell
  191.       '((prin1 custom-prin1)
  192.         (princ custom-princ)
  193.         (print custom-print)
  194.         (prin1-to-string custom-prin1-to-string)
  195.         (format custom-format)
  196.         (message custom-message)
  197.         (error custom-error)
  198.         )))
  199.   
  200. (defun uninstall-custom-print-funcs ()
  201.   "Reset print functions to their internal subroutines."
  202.   (interactive)
  203.   (mapcar 'cust-print-set-function-cell
  204.       '((prin1 cust-print-internal-prin1)
  205.         (princ cust-print-internal-princ)
  206.         (print cust-print-internal-print)
  207.         (prin1-to-string cust-print-internal-prin1-to-string)
  208.         (format cust-print-internal-format)
  209.         (message cust-print-internal-message)
  210.         (error cust-print-internal-error)
  211.         )))
  212.  
  213.  
  214. ;;===============================================================
  215. ;; Lisp replacements for prin1 and princ and for subrs that use prin1 
  216. ;; (or princ) -- so far only the printing and formatting subrs.
  217.  
  218. (defun custom-prin1 (object &optional stream)
  219.   "Replacement for standard `prin1'.
  220. Uses the appropriate printer depending on the values of `print-level'
  221. and `print-circle' (which see).
  222.  
  223. Output the printed representation of OBJECT, any Lisp object.
  224. Quoting characters are printed when needed to make output that `read'
  225. can handle, whenever this is possible.
  226. Output stream is STREAM, or value of `standard-output' (which see)."
  227.   (cust-print-top-level object stream 'cust-print-internal-prin1))
  228.  
  229.  
  230. (defun custom-princ (object &optional stream)
  231.   "Same as `custom-prin1' except no quoting."
  232.   (cust-print-top-level object stream 'cust-print-internal-princ))
  233.  
  234. (defvar custom-prin1-chars)
  235.  
  236. (defun custom-prin1-to-string-func (c)
  237.   "Stream function for `custom-prin1-to-string'."
  238.   (setq custom-prin1-chars (cons c custom-prin1-chars)))
  239.  
  240. (defun custom-prin1-to-string (object)
  241.   "Replacement for standard `prin1-to-string'."
  242.   (let ((custom-prin1-chars nil))
  243.     (custom-prin1 object 'custom-prin1-to-string-func)
  244.     (concat (nreverse custom-prin1-chars))))
  245.  
  246.  
  247. (defun custom-print (object &optional stream)
  248.   "Replacement for standard `print'."
  249.   (cust-print-internal-princ "\n")
  250.   (custom-prin1 object stream)
  251.   (cust-print-internal-princ "\n"))
  252.  
  253.  
  254. (defun custom-format (fmt &rest args)
  255.   "Replacement for standard `format'.
  256.  
  257. Calls format after first making strings for list or vector args.
  258. The format specification for such args should be `%s' in any case, so a
  259. string argument will also work.  The string is generated with
  260. `custom-prin1-to-string', which quotes quotable characters."
  261.   (apply 'cust-print-internal-format fmt
  262.      (mapcar (function (lambda (arg)
  263.                  (if (or (listp arg) (vectorp arg))
  264.                  (custom-prin1-to-string arg)
  265.                    arg)))
  266.          args)))
  267.         
  268.   
  269.  
  270. (defun custom-message (fmt &rest args)
  271.   "Replacement for standard `message' that works like `custom-format'."
  272.   ;; It doesn't work to princ the result of custom-format
  273.   ;; because the echo area requires special handling
  274.   ;; to avoid duplicating the output.  cust-print-internal-message does it right.
  275.   ;; (cust-print-internal-princ (apply 'custom-format fmt args))
  276.   (apply 'cust-print-internal-message  fmt
  277.      (mapcar (function (lambda (arg)
  278.                  (if (or (listp arg) (vectorp arg))
  279.                  (custom-prin1-to-string arg)
  280.                    arg)))
  281.          args)))
  282.         
  283.  
  284. (defun custom-error (fmt &rest args)
  285.   "Replacement for standard `error' that uses `custom-format'"
  286.   (signal 'error (list (apply 'custom-format fmt args))))
  287.  
  288.  
  289. ;;=========================================
  290. ;; Support for custom prin1 and princ
  291.  
  292. (defvar circle-table)
  293. (defvar circle-tree)
  294. (defvar circle-level)
  295.  
  296. (defun cust-print-top-level (object stream internal-printer)
  297.   "Set up for printing."
  298.   (let ((standard-output (or stream standard-output))
  299.     (circle-table (and print-circle (cust-print-preprocess-circle-tree object)))
  300.     (circle-level (or print-level -1))
  301.     )
  302.  
  303.     (defalias 'cust-print-internal-printer internal-printer)
  304.     (defalias 'cust-print-low-level-prin 
  305.       (cond
  306.        ((or custom-print-list
  307.         custom-print-vector
  308.         print-level ; comment out for version 19
  309.         )
  310.         'cust-print-custom-object)
  311.        (circle-table
  312.         'cust-print-object)
  313.        (t 'cust-print-internal-printer)))
  314.     (defalias 'cust-print-prin (if circle-table 'cust-print-circular 'cust-print-low-level-prin))
  315.  
  316.     (cust-print-prin object)
  317.     object))
  318.  
  319.  
  320. ;; Test object type and print accordingly.
  321. (defun cust-print-object (object)
  322.   ;; Could be called as either cust-print-low-level-prin or cust-print-prin.
  323.   (cond 
  324.    ((null object) (cust-print-internal-printer object))
  325.    ((consp object) (cust-print-list object))
  326.    ((vectorp object) (cust-print-vector object))
  327.    ;; All other types, just print.
  328.    (t (cust-print-internal-printer object))))
  329.  
  330.  
  331. ;; Test object type and print accordingly.
  332. (defun cust-print-custom-object (object)
  333.   ;; Could be called as either cust-print-low-level-prin or cust-print-prin.
  334.   (cond 
  335.    ((null object) (cust-print-internal-printer object))
  336.  
  337.    ((consp object) 
  338.     (or (and custom-print-list
  339.          (cust-print-custom-object1 object custom-print-list))
  340.     (cust-print-list object)))
  341.  
  342.    ((vectorp object) 
  343.     (or (and custom-print-vector
  344.          (cust-print-custom-object1 object custom-print-vector))
  345.     (cust-print-vector object)))
  346.  
  347.    ;; All other types, just print.
  348.    (t (cust-print-internal-printer object))))
  349.  
  350.  
  351. ;; Helper for cust-print-custom-object.
  352. ;; Print the custom OBJECT using the custom type ALIST.
  353. ;; For the first predicate that matches the object, the corresponding
  354. ;; converter is evaluated with the object and the string that results is
  355. ;; printed with princ.  Return nil if no predicate matches the object.
  356. (defun cust-print-custom-object1 (object alist)
  357.   (while (and alist (not (funcall (car (car alist)) object)))
  358.     (setq alist (cdr alist)))
  359.   ;; If alist is not null, then something matched.
  360.   (if alist
  361.       (cust-print-internal-princ
  362.        (funcall (cdr (car alist)) object) ; returns string
  363.        )))
  364.  
  365.  
  366. (defun cust-print-circular (object)
  367.   "Printer for `prin1' and `princ' that handles circular structures.
  368. If OBJECT appears multiply, and has not yet been printed,
  369. prefix with label; if it has been printed, use `#N#' instead.
  370. Otherwise, print normally."
  371.   (let ((tag (assq object circle-table)))
  372.     (if tag
  373.     (let ((id (cdr tag)))
  374.       (if (> id 0)
  375.           (progn
  376.         ;; Already printed, so just print id.
  377.         (cust-print-internal-princ "#")
  378.         (cust-print-internal-princ id)
  379.         (cust-print-internal-princ "#"))
  380.         ;; Not printed yet, so label with id and print object.
  381.         (setcdr tag (- id)) ; mark it as printed
  382.         (cust-print-internal-princ "#")
  383.         (cust-print-internal-princ (- id))
  384.         (cust-print-internal-princ "=")
  385.         (cust-print-low-level-prin object)
  386.         ))
  387.       ;; Not repeated in structure.
  388.       (cust-print-low-level-prin object))))
  389.  
  390.  
  391. ;;================================================
  392. ;; List and vector processing for print functions.
  393.  
  394. ;; Print a list using print-length, print-level, and print-circle.
  395. (defun cust-print-list (list)
  396.   (if (= circle-level 0)
  397.       (cust-print-internal-princ "#")
  398.     (let ((circle-level (1- circle-level)))
  399.       (cust-print-internal-princ "(")
  400.       (let ((length (or print-length 0)))
  401.  
  402.     ;; Print the first element always (even if length = 0).
  403.     (cust-print-prin (car list))
  404.     (setq list (cdr list))
  405.     (if list (cust-print-internal-princ " "))
  406.     (setq length (1- length))
  407.  
  408.     ;; Print the rest of the elements.
  409.     (while (and list (/= 0 length))
  410.       (if (and (listp list)
  411.            (not (assq list circle-table)))
  412.           (progn
  413.         (cust-print-prin (car list))
  414.         (setq list (cdr list)))
  415.  
  416.         ;; cdr is not a list, or it is in circle-table.
  417.         (cust-print-internal-princ ". ")
  418.         (cust-print-prin list)
  419.         (setq list nil))
  420.  
  421.       (setq length (1- length))
  422.       (if list (cust-print-internal-princ " ")))
  423.  
  424.     (if (and list (= length 0)) (cust-print-internal-princ "..."))
  425.     (cust-print-internal-princ ")"))))
  426.   list)
  427.  
  428.  
  429. ;; Print a vector according to print-length, print-level, and print-circle.
  430. (defun cust-print-vector (vector)
  431.   (if (= circle-level 0)
  432.       (cust-print-internal-princ "#")
  433.     (let ((circle-level (1- circle-level))
  434.       (i 0)
  435.       (len (length vector)))
  436.       (cust-print-internal-princ "[")
  437.  
  438.       (if print-length
  439.       (setq len (min print-length len)))
  440.       ;; Print the elements
  441.       (while (< i len)
  442.     (cust-print-prin (aref vector i))
  443.     (setq i (1+ i))
  444.     (if (< i (length vector)) (cust-print-internal-princ " ")))
  445.  
  446.       (if (< i (length vector)) (cust-print-internal-princ "..."))
  447.       (cust-print-internal-princ "]")
  448.       ))
  449.   vector)
  450.  
  451.  
  452. ;;==================================
  453. ;; Circular structure preprocessing
  454.  
  455. (defun cust-print-preprocess-circle-tree (object)
  456.   ;; Fill up the table.  
  457.   (let (;; Table of tags for each object in an object to be printed.
  458.     ;; A tag is of the form:
  459.     ;; ( <object> <nil-t-or-id-number> )
  460.     ;; The id-number is generated after the entire table has been computed.
  461.     ;; During walk through, the real circle-table lives in the cdr so we
  462.     ;; can use setcdr to add new elements instead of having to setq the
  463.     ;; variable sometimes (poor man's locf).
  464.     (circle-table (list nil)))
  465.     (cust-print-walk-circle-tree object)
  466.  
  467.     ;; Reverse table so it is in the order that the objects will be printed.
  468.     ;; This pass could be avoided if we always added to the end of the
  469.     ;; table with setcdr in walk-circle-tree.
  470.     (setcdr circle-table (nreverse (cdr circle-table)))
  471.  
  472.     ;; Walk through the table, assigning id-numbers to those
  473.     ;; objects which will be printed using #N= syntax.  Delete those
  474.     ;; objects which will be printed only once (to speed up assq later).
  475.     (let ((rest circle-table)
  476.       (id -1))
  477.       (while (cdr rest)
  478.     (let ((tag (car (cdr rest))))
  479.       (cond ((cdr tag)
  480.          (setcdr tag id)
  481.          (setq id (1- id))
  482.          (setq rest (cdr rest)))
  483.         ;; Else delete this object.
  484.         (t (setcdr rest (cdr (cdr rest))))))
  485.     ))
  486.     ;; Drop the car.
  487.     (cdr circle-table)
  488.     ))
  489.  
  490.  
  491.  
  492. (defun cust-print-walk-circle-tree (object)
  493.   (let (read-equivalent-p tag)
  494.     (while object
  495.       (setq read-equivalent-p (or (numberp object) (symbolp object))
  496.         tag (and (not read-equivalent-p)
  497.              (assq object (cdr circle-table))))
  498.       (cond (tag
  499.          ;; Seen this object already, so note that.
  500.          (setcdr tag t))
  501.  
  502.         ((not read-equivalent-p)
  503.          ;; Add a tag for this object.
  504.          (setcdr circle-table
  505.              (cons (list object)
  506.                (cdr circle-table)))))
  507.       (setq object
  508.         (cond 
  509.          (tag ;; No need to descend since we have already.
  510.           nil)
  511.  
  512.          ((consp object)
  513.           ;; Walk the car of the list recursively.
  514.           (cust-print-walk-circle-tree (car object))
  515.           ;; But walk the cdr with the above while loop
  516.           ;; to avoid problems with max-lisp-eval-depth.
  517.           ;; And it should be faster than recursion.
  518.           (cdr object))
  519.  
  520.          ((vectorp object)
  521.           ;; Walk the vector.
  522.           (let ((i (length object))
  523.             (j 0))
  524.         (while (< j i)
  525.           (cust-print-walk-circle-tree (aref object j))
  526.           (setq j (1+ j))))))))))
  527.  
  528.  
  529.  
  530. ;;=======================================
  531.  
  532. ;; Example.
  533.  
  534. ;;;; Create some circular structures.
  535. ;;(setq circ-sym (let ((x (make-symbol "FOO"))) (list x x)))
  536. ;;(setq circ-list (list 'a 'b (vector 1 2 3 4) 'd 'e 'f))
  537. ;;(setcar (nthcdr 3 circ-list) circ-list)
  538. ;;(aset (nth 2 circ-list) 2 circ-list)
  539. ;;(setq dotted-circ-list (list 'a 'b 'c))
  540. ;;(setcdr (cdr (cdr dotted-circ-list)) dotted-circ-list)
  541. ;;(setq circ-vector (vector 1 2 3 4 (list 'a 'b 'c 'd) 6 7))
  542. ;;(aset circ-vector 5 (make-symbol "-gensym-"))
  543. ;;(setcar (cdr (aref circ-vector 4)) (aref circ-vector 5))
  544.  
  545. ;;(install-custom-print-funcs)
  546. ;;;; (setq print-circle t)
  547.  
  548. ;;(let ((print-circle t))
  549. ;;  (or (equal (prin1-to-string circ-list) "#1=(a b [1 2 #1# 4] #1# e f)")
  550. ;;      (error "circular object with array printing")))
  551.  
  552. ;;(let ((print-circle t))
  553. ;;  (or (equal (prin1-to-string dotted-circ-list) "#1=(a b c . #1#)")
  554. ;;      (error "circular object with array printing")))
  555.  
  556. ;;(let* ((print-circle t)
  557. ;;       (x (list 'p 'q))
  558. ;;       (y (list (list 'a 'b) x 'foo x)))
  559. ;;  (setcdr (cdr (cdr (cdr y))) (cdr y))
  560. ;;  (or (equal (prin1-to-string y) "((a b) . #1=(#2=(p q) foo #2# . #1#))"
  561. ;;         )
  562. ;;      (error "circular list example from CL manual")))
  563.  
  564. ;;;; There's no special handling of uninterned symbols in custom-print.
  565. ;;(let ((print-circle nil))
  566. ;;  (or (equal (prin1-to-string circ-sym) "(#:FOO #:FOO)")
  567. ;;      (error "uninterned symbols in list")))
  568. ;;(let ((print-circle t))
  569. ;;  (or (equal (prin1-to-string circ-sym) "(#1=FOO #1#)")
  570. ;;      (error "circular uninterned symbols in list")))
  571. ;;(uninstall-custom-print-funcs)
  572.  
  573. ;;; cust-print.el ends here
  574.